home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / cig / libcig.scm < prev    next >
Text File  |  1995-10-13  |  4KB  |  133 lines
  1. ;;; (DEFINE-FOREIGN ...) forms are expanded by Cig into Scheme stubs.
  2. ;;; These stubs reference some support procedures to rep-convert the
  3. ;;; standard reps (e.g., string). This structure provides these support 
  4. ;;; procedures.
  5. ;;;
  6. ;;; We export three kinds of things:
  7. ;;; - Type predicates that aren't in the R4RS env (e.g., FIXNUM?).
  8. ;;; - Carrier makers for making boxes to return things in.
  9. ;;; - Scheme-side rep-converters for return values.
  10.  
  11. (define-structure cig-aux
  12.   (export cstring-null?
  13.       C->scheme-string
  14.       C->scheme-string-w/len
  15.       C->scheme-string-w/len-no-free
  16.       C-string-vec->Scheme&free
  17.       C-string-vec->Scheme ; Bogus, because clients not reentrant.
  18.       string-carrier->string
  19.       string-carrier->string-no-free
  20.       fixnum?
  21.       make-string-carrier
  22.       make-alien
  23.       alien?
  24.       )
  25.   (open scheme code-vectors define-foreign-syntax)
  26.  
  27.   (begin
  28.     (define min-fixnum (- (expt 2 29)))
  29.     (define max-fixnum (- (expt 2 29) 1))
  30.     (define (fixnum? x) (and (integer? x) (<= min-fixnum x max-fixnum)))
  31.  
  32.     ;; Internal utility.
  33.     (define (mapv! f v)
  34.       (let ((len (vector-length v)))
  35.     (do ((i 0 (+ i 1)))
  36.         ((= i len) v)
  37.       (vector-set! v i (f (vector-ref v i))))))
  38.  
  39.     ;; Make a carrier for returning strings. 
  40.     ;; It holds a raw C string and a fixnum giving the length of the string.
  41.     (define (make-string-carrier) (cons (make-alien) 0))
  42.  
  43.     (define (make-alien) (make-code-vector 4 0))
  44.     (define (alien? x) (and (code-vector? x) (= 4 (code-vector-length x)))) ; BOGUS
  45.  
  46.  
  47. ;;; C/Scheme string and vector conversion
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49.  
  50. ;;; Generally speaking, in the following routines, 
  51. ;;; a NULL C string param causes a function to return #f.
  52.  
  53. (define-foreign %cstring-length-or-false
  54.   (strlen_or_false ((C "const char * ~a") cstr))
  55.   desc)
  56.  
  57. (define-foreign cstring-null?
  58.   (cstring_nullp ((C "const char * ~a") cstr))
  59.   bool)
  60.  
  61. (define-foreign %copy-c-string&free
  62.   (c2scheme_strcpy_free (string-desc sstr) ((C char*) cstr))
  63.   bool)
  64.  
  65. (define-foreign %copy-c-string
  66.   (c2scheme_strcpy (string-desc sstr) ((C char*) cstr))
  67.   bool)
  68.  
  69. (define (C->scheme-string cstr)
  70.   (cond ((%cstring-length-or-false cstr)
  71.      => (lambda (strlen)
  72.           (let ((str (make-string strlen)))
  73.         (%copy-c-string&free str cstr)
  74.         str)))
  75.     (else #f)))
  76.  
  77. (define (C->scheme-string-w/len cstr len)
  78.   (and (integer? len)
  79.        (let ((str (make-string len)))
  80.      (%copy-c-string&free str cstr)
  81.      str)))
  82.  
  83. (define (C->scheme-string-w/len-no-free cstr len)
  84.   (and (integer? len)
  85.        (let ((str (make-string len)))
  86.      (%copy-c-string str cstr)
  87.      str)))
  88.  
  89. (define (string-carrier->string carrier)
  90.   (C->scheme-string-w/len (car carrier) (cdr carrier)))
  91.  
  92. (define (string-carrier->string-no-free carrier)
  93.   (C->scheme-string-w/len-no-free (car carrier) (cdr carrier)))
  94.  
  95. ;;; Return the length of a null-terminated C word vector. 
  96. ;;; Does not count the null word as part of the length.
  97. ;;; If vector is NULL, returns #f.
  98.  
  99. (define-foreign %c-veclen-or-false
  100.   (c_veclen ((C long*) c-vec))
  101.   desc) ; integer or #f if arg is NULL.
  102.  
  103. ;;; CVEC is a C vector of char* strings, length VECLEN.
  104. ;;; This procedure converts a C vector of strings into a Scheme vector of 
  105. ;;; strings. The C vector and its strings are all assumed to come from
  106. ;;; the malloc heap; they are returned to the heap when the rep-conversion
  107. ;;; is done.
  108. ;;;
  109. ;;; Hack: if VECLEN is #f, CVEC is assumed to be NULL terminated, and
  110. ;;; its length is calculated thusly.
  111.  
  112. (define (C-string-vec->Scheme&free cvec veclen)
  113.   (let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0))))
  114.     (mapv! (lambda (ignore) (make-string-carrier)) vec)
  115.     (%set-string-vector-carriers! vec cvec)
  116.     (C-free cvec)
  117.     (mapv! string-carrier->string vec)))
  118.  
  119. (define (C-string-vec->Scheme cvec veclen) ; No free.
  120.   (let ((vec (make-vector (or veclen (%c-veclen-or-false cvec) 0))))
  121.     (mapv! (lambda (ignore) (make-string-carrier)) vec)
  122.     (%set-string-vector-carriers! vec cvec)
  123.     (mapv! string-carrier->string-no-free vec)))
  124.  
  125.  
  126. (define-foreign C-free (free ((C void*) ptr)) ignore)
  127.  
  128. (define-foreign %set-string-vector-carriers!
  129.   (set_strvec_carriers (vector-desc svec) ((C char**) cvec))
  130.   ignore)
  131.  
  132. )) ; egakcap
  133.